home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmptype.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
7KB
|
182 lines
;;; CMPTYPE Type information.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
;;; CL-TYPE is any valid type specification of Common Lisp.
;;;
;;; TYPE is a representation type used by KCL. TYPE is one of:
;;;
;;; T(BOOLEAN)
;;;
;;; FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT
;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM)
;;; (VECTOR SHORT-FLOAT) (VECTOR LONG-FLOAT)
;;; (ARRAY T) (ARRAY STRING-CHAR) (ARRAY BIT)
;;; (ARRAY FIXNUM)
;;; (ARRAY SHORT-FLOAT) (ARRAY LONG-FLOAT)
;;; UNKNOWN
;;;
;;; NIL
;;;
;;;
;;; immediate-type:
;;; FIXNUM int
;;; CHARACTER char
;;; SHORT-FLOAT float
;;; LONG-FLOAT double
;;; Check if THING is an object of the type TYPE.
;;; Depends on the implementation of TYPE-OF.
(defun object-type (thing)
(let ((type (type-of thing)))
(case type
((fixnum short-float long-float) type)
((string-char standard-char character) 'character)
((string bit-vector) type)
(vector (list 'vector (array-element-type thing)))
(array (list 'array (array-element-type thing)))
(t 'unknown))))
(defun type-filter (type)
(case type
((fixnum character short-float long-float) type)
(single-float 'long-float)
(double-float 'long-float)
((simple-string string) 'string)
((simple-bit-vector bit-vector) 'bit-vector)
(t (let ((type (si::normalize-type type)) element-type)
(case (car type)
((simple-array array)
(cond ((or (endp (cdr type))
(not (setq element-type
(case (cadr type)
(* nil)
((string-char standard-char character)
'string-char)
(bit 'bit)
(fixnum 'fixnum)
((short-float)
'short-float)
((long-float
double-float single-float)
'long-float)
(t t)))))
t) ; I don't know.
((and (not (endp (cddr type)))
(not (eq (caddr type) '*))
(= (length (caddr type)) 1))
(case element-type
(string-char 'string)
(bit 'bit-vector)
(t (list 'vector element-type))))
(t (list 'array element-type))))
(integer
(if (si::sub-interval-p (cdr type)
(list most-negative-fixnum
most-positive-fixnum))
'fixnum
t))
((short-float) 'short-float)
((long-float double-float single-float) 'long-float)
(t (cond ((subtypep type 'fixnum) 'fixnum)
((subtypep type 'character) 'character)
((subtypep type 'short-float) 'short-float)
((subtypep type 'long-float) 'long-float)
((subtypep type '(vector t)) '(vector t))
((subtypep type 'string) 'string)
((subtypep type 'bit-vector) 'bit-vector)
((subtypep type '(vector fixnum)) '(vector fixnum))
((subtypep type '(vector short-float))
'(vector short-float))
((subtypep type '(vector long-float))
'(vector long-float))
((subtypep type '(array t)) '(array t))
((subtypep type '(array string-char))
'(array string-char))
((subtypep type '(array bit)) '(array bit))
((subtypep type '(array fixnum)) '(array fixnum))
((subtypep type '(array short-float))
'(array short-float))
((subtypep type '(array long-float))
'(array long-float))
(t t)))
)))))
(defun type-and (type1 type2)
(cond ((equal type1 type2) type1)
((eq type1 t) type2)
((eq type2 t) type1)
((consp type1)
(case (car type1)
(array
(case (cadr type1)
(string-char (if (eq type2 'string) type2 nil))
(bit (if (eq type2 'bit-vector) type2 nil))
(t (if (and (consp type2)
(eq (car type2) 'vector)
(eq (cadr type1) (cadr type2)))
type2 nil))))
(vector
(if (and (consp type2) (eq (car type2) 'array)
(eq (cadr type1) (cadr type2)))
type1 nil))
(t nil)))
(t (case type1
(string
(if (and (consp type2) (eq (car type2) 'array)
(eq (cadr type2) 'string-char))
type1 nil))
(bit-vector
(if (and (consp type2) (eq (car type2) 'array)
(eq (cadr type2) 'bit))
type1 nil))
(fixnum-float
(if (member type2 '(fixnum float short-float long-float))
type2 nil))
(float
(if (member type2 '(short-float long-float))
type2 nil))
((long-float short-float)
(if (member type2 '(fixnum-float float))
type1 nil))
(fixnum
(if (eq type2 'fixnum-float) 'fixnum nil))))))
(defun type>= (type1 type2)
(equal (type-and type1 type2) type2))
(defun reset-info-type (info)
(if (info-type info)
(let ((info1 (copy-info info)))
(setf (info-type info1) t)
info1)
info))
(defun and-form-type (type form original-form &aux type1)
(setq type1 (type-and type (info-type (cadr form))))
(when (null type1)
(cmpwarn "The type of the form ~s is not ~s." original-form type))
(if (eq type1 (info-type (cadr form)))
form
(let ((info (copy-info (cadr form))))
(setf (info-type info) type1)
(list* (car form) info (cddr form)))))
(defun check-form-type (type form original-form)
(when (null (type-and type (info-type (cadr form))))
(cmpwarn "The type of the form ~s is not ~s." original-form type)))
(defun default-init (type)
(case type
(fixnum (cmpwarn "The default value of NIL is not FIXNUM."))
(character (cmpwarn "The default value of NIL is not CHARACTER."))
(long-float (cmpwarn "The default value of NIL is not LONG-FLOAT."))
(short-float (cmpwarn "The default value of NIL is not SHORT-FLOAT."))
)
(c1nil))